home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / procs.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  3.5 KB  |  99 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module procs macro)
  13.  
  14. ;;; Fast dispatching off the property list with SUBRCALL.
  15. ;;; MARCH 1980. -GJC
  16.  
  17. ;;; The advantages:
  18. ;;; [1] (SUBRCALL NIL (GET (CAR FORM) 'FOO) FORM) is fast! (PUSHJ P @ 0 P)
  19. ;;; [2] Creates no extra symbols of the kind |NAME FOO|.
  20. ;;; The problems with using SUBRCALL:
  21. ;;; [1] Only have subrs in compiled code.
  22. ;;; [2] System-dependant.
  23. ;;; [3] Fixed number of arguments.
  24.  
  25. ;;; This macro package fixes problems [1] and [2]. 
  26. ;;; Number [3] isn't a problem for the parsers, translators and tree-walkers
  27. ;;; in macsyma.
  28.  
  29. (defun verify-as-subr-argument-list (property l n)
  30.   (if (or (memq '&rest l)
  31.       (memq '&optional l))
  32.       (MAXIMA-ERROR (list "bad argument list for a" property "property.") l)
  33.       (let ((length (f- (length l)
  34.                (length (memq '&aux l)))))
  35.     (if (eq n '*)
  36.         (if (< length 6.)
  37.         length
  38.         (MAXIMA-ERROR (list "argument list too long for a" property "property.") l))
  39.         (if (= n length)
  40.         length
  41.         (MAXIMA-ERROR (list "argument list for a" property "property must be"
  42.                  n "long.")
  43.                l))))))
  44.  
  45.  
  46. (defun a-def-property (name argl body property n)
  47.   (verify-as-subr-argument-list property argl n)
  48.   (cond
  49.     #-cl
  50.     ((status feature pdp10)
  51.      (cond ((memq compiler-state '(maklap compile))
  52.         `(defun-prop (,name nil ,property) ,argl . ,body))
  53.            ('else
  54.         (let ((f (symbolconc name '- property)))
  55.           `(progn (defprop ,name ,(make-jcall n f) ,property)
  56.               (defun ,f ,argl . ,body))))))
  57.     ('else
  58.      `(defun-prop (,name ,property) ,argl . ,body))))
  59.      
  60. (defmacro def-def-property (name sample-arglist)
  61.   
  62.   `(defmacro ,(symbolconc 'def- name '-property) (name argl . body)
  63.      (a-def-property name argl body ',name 
  64.              ',(verify-as-subr-argument-list 'def-def-property
  65.                                sample-arglist
  66.                                '*))))
  67.  
  68. #+PDP10
  69. (progn 'compile
  70. (defun make-jcall (number-of-arguments name-to-call)
  71.   (boole  boole-ior #.(f* 13 (^ 2 27.))
  72.      (lsh number-of-arguments 23.)
  73.      (maknum name-to-call)))
  74. ;; SUBRCALL does argument checking in the interpreter, so
  75. ;; the FIXNUM's won't pass as subr-pointers.
  76. ;; The following code must be compiled in order to run interpreted code
  77. ;; which uses SUBR-CALL and DEF-DEF-PROPERTY.
  78. (defun subr-call-0 (f)          (subrcall nil f))
  79. (defun subr-call-1 (f a)        (subrcall nil f a))
  80. (defun subr-call-2 (f a b)      (subrcall nil f a b))
  81. (defun subr-call-3 (f a b c)    (subrcall nil f a b c))
  82. (defun subr-call-4 (f a b c d)  (subrcall nil f a b c d))
  83. (defun subr-call-5 (f a b c d e)(subrcall nil f a b c d e))
  84. (DEFMACRO SUBR-CALL (F &REST L)
  85.   (IF (MEMQ COMPILER-STATE '(MAKLAP COMPILE))
  86.       `(SUBRCALL NIL ,F ,@L)
  87.       `(,(cdr (zl-ASSOC (length l)
  88.                    '((0 . subrcall-0)
  89.                  (1 . subrcall-1)
  90.                  (2 . subrcall-2)
  91.                  (3 . subrcall-3)
  92.                  (4 . subrcall-4)
  93.                  (5 . subrcall-5))))
  94.           ,f ,@l)))
  95. )
  96.  
  97. #-PDP10
  98. (DEFMACRO SUBR-CALL (F &REST L) `(FUNCALL ,F ,@L))
  99.